perm filename SCMSS.F4[XX,LCS]3 blob
sn#194620 filedate 1975-12-29 generic text, type T, neo UTF8
00010 C****** SCMSS, LNEND *********** 12/1/75
00100 SUBROUTINE SCMSS
00105 INTEGER PWDS
00110 COMMON /PLTR/PLT,RHT,DIS/PTR/PWDS(250),ITEM,LL,IS,IX
00300 COMMON R2,JA,G,H,R3,U(39)/SCM/V(78),I,LCNT,STAFF,JLIST(200),REND
00350 C JLIST WILL SOMETIMES BE USED(WIPED OUT) FOR R(X,Y) OVERFLOW(>50 ITEMS.)
00500 DIMENSION RLIST(200),NOMOR(6),WARN(6),R(10,80),ISV(5)
00550 C /SCX/ ALSO IN WORDS, NEWR
00600 COMMON/SCX/RHY(4),JALPHA(30),RB,RC,JZ,IRHY,JD,KA,KB,IZ
00610 1/STF/RSTFAC(8),RSTJ2/FRMT/F78F(1),FA1(1),FA5(1),IREAD
00700 1/XRN/RN(4000) /ALF/INP(72),ML
00800 COMMON /SC/J,L,MK,ISKP,XMINUS,N,IEXP,LK,NNUM,JJ,JN,DBST
00900 1,NFLG,IXX,ISEMI,JG,VX(50),IAMP,K,KN,M,MODE,IBLA
01100 EQUIVALENCE (VX1,VX(1)),(INP1,INP(1)),(VX2,VX(2)),(VX3,VX(3))
01200 1,(VX4,VX(4)),(VX5,VX(5)),(JLIST,RLIST),(R,RN(3001))
01300 1 ,(INP2,INP(2)),(INP3,INP(3)),(INP4,INP(4)),(IBEAM,RN(3000))
01400 1,(ISTAR,JALPHA(8)),(ICOL,JALPHA(9)),(IRP,JALPHA(6)),
01410 1(ILP,JALPHA(5)),(NEG,JALPHA(2)),(IAT,JALPHA(16)),(IDOT,
01455 1JALPHA(3)),(RMODE2,RN(3918)),(SET4,RN(3920)),(NOSET,RN(3923))
01500 DATA KSLA/'/'/,IXX/'X'/,LCNT/1/,RHY/.5,.25,.125,.0625/
01600 1,ISEMI/';'/
01900 1177 IF(JA.EQ.14)GO TO 77
01950 IF(JA.NE.144)GO TO 11
02000 77 MODE=1
02050 RMODE2=R3
02060 TYPE 444,SET4
02100 IBEAM=-1
02200 IZ=0
02300 IREAD=0
02400 11 IF(IREAD)GO TO 2302
02500 IF(JA.NE.144)GO TO (1,2,3,4,5,69)MODE
02600 2302 TYPE 80053
02650 IF(IREAD)REREAD 21141,L,INP
02700 IF(IREAD.EQ.0)TYPE 80051
02800 ACCEPT 80052,STAFF,L
02810 IF(STAFF.NE.444)GO TO 2177
02820 3177 REREAD 4177,SET4,SET4
02830 C NOW SPACER CAN BE SET AT THIS POINT
02840 GO TO 1177
02845 4177 FORMAT(2F)
02850 2177 IF(STAFF.GE.99)GO TO 690
02875 C TYPE 99 OR 999 TO ESCAPE WHEN IN READ-IN MODE
02887 REND=0
02900 IF(IREAD)GO TO 80041
02950 IF(LOOK(L)+LOOKD(L).EQ.0)GO TO 2302
03000 IREAD=-1
03055 C FOR 1ST TIME IN BEAMS.
03100 REWIND 22
03200 CALL IFILE(22,L)
03300 2301 READ(22,21141,END=68),L,INP
03400 IF(MODE.EQ.6)GO TO 1111
03500 IF(INP1.EQ.IBLA)GO TO 8006
03600 CC GO TO 80041
03650 GO TO 6177
03700 1111 MODE=1
03800 REND=2
03900 IZ=0
04000 CC RETURN
04200 C ABOVE ALLOWS MORE STAVES TO BE READ
04220 168 IF(NOSET.EQ.0)RETURN
04240 DO 1168 K=NIT,JIT+NIT-1
04260 L=PWDS(K)
04280 RA=RN(L+1)
04300 IF(RA.GT.2)GO TO 1168
04320 N=9
04340 IF(RA.EQ.2)N=7
04360 RN(L+N)=0
04380 C ZEROS RHYTHM OF ADDED INPUT ON SPACING STAFF
04400 1168 CONTINUE
04420 RETURN
04780
04800 80053 FORMAT(' TYPE STAFF NUM. '$)
04900 80051 FORMAT('+AND FILE NAME '$)
05000 80052 FORMAT(F,A5)
05010 444 FORMAT(' SPACING STAFF =',F3.0)
05100
05400 4 TYPE 8002
05500 330 ACCEPT 2114,N,L,INP3,INP4
05600 CC IF(N.EQ.'G')GO TO 8024
05650 IF(N.EQ.'G')GO TO 69
05700 C TYPE 'GO' TO PASS LATER ITEMS
05800 IF(N.EQ.'9')GO TO 99
05850 IF(N.EQ.'B')GO TO 99
05900 IF(N.EQ.'Y')GO TO 1
05925 IF(L.EQ.'B')GO TO 134
05931 IF(INP3.EQ.'B')GO TO 134
05937 C FOR BEAMS? TYPE 'nB' INSTEAD OF 'Y' FOR AUTOMATIC.
05950 IF(N.EQ.'N')GO TO 2000
05962 IF(N.NE.IBLA)GO TO 11
05975 C PICKS UP TYPOS
06000 2000 MODE=MODE+1
06050 WRITE(21,2114)INP4
06100 GO TO 11
06130 691 FORMAT(' INPUT SAVED ON FOR21.DAT')
06140 69 END FILE 21
06145 TYPE 691
06150 690 REND=1
06175 CC RETURN
06187 GO TO 168
06200 3 TYPE 8023
06300 GO TO 330
06400 5 TYPE 8022
06500 GO TO 330
06610 8024 CALL HYDPOG(3)
06655 C ERASES NOTE NUMBERS
06800 C JUMP IF NO STEM NORMALIZATION NEEDED
06900 C IF(MODE.LT.3)GO TO 8006
07300 C ADJUSTS NOTE STEMS, ETC.
07400 8006 MODE=MODE+1
07410 IF(MODE.NE.2)GO TO 177
07415 IF(RMODE2.EQ.2)GO TO 80041
07420 C FOR NEW INPUT FORMAT -- TYPE 14 2 OR 144 -2 ETC.
07500 177 IF(IREAD)GO TO 2301
07600 IF(MODE.LE.5)RETURN
07620 END FILE 21
07660 TYPE 691
07700 68 REND=-1
07750 CC RETURN
07850 GO TO 168
07900
08300
09000 99 IF(INP3.EQ.'9')GO TO 999
09200 C ELSE GET ANOTHER CHANCE TO SAY 'NO'
09300 C 99=BACKUP, 999=ESCAPE
09400 MODE=MODE-1
09600 IF(MODE.EQ.0)GO TO 999
09610 IS=ISV(MODE)
09620 GO TO 11
09650 C INSERT BACKUP ROUTINE
09700 999 REND=99
09800 RETURN
10550 C FIX BACKUPS********
10600
10800 8008 FORMAT(' TYPE ',I2,' RHYTHMS')
10900 8002 FORMAT(' ADD BEAMS? '$)
11000 8022 FORMAT(' ADD SLURS? '$)
11100 8023 FORMAT(' ADD MARKS? '$)
11200 8011 FORMAT(1XI3,' MORE RHYTHMS NEEDED'/)
11210 8015 K=IRHY-I+1
11400 TYPE 8011,K
11500 IF(IREAD)IREAD=1
11550 C ↑↑↑↑↑ SO YOU CAN TYPE MORE LINES WHEN ERROR ON READIN.
11600 2 TYPE 8008,IRHY
12000
12350 1 ISV(MODE)=IS
12400 CALL TYPE
12410 REREAD 4177,RA,RB
12420 IF(RA.NE.444)GO TO 5177
12430 SET4=RB
12440 C CAN SET SPACER HERE
12450 GO TO 1177
12600 5177 IF(INP1.EQ.IBLA) GO TO 1
12700 IF(INP1.NE.'9')GO TO 80041
12750 IF(INP2.EQ.'9')GO TO 99
12800 C TYPE '99' TO BACK-UP
12850 80041 WRITE(21,2114)INP
12875 6177 CALL LNEND
12900 IF(MODE.GE.3)GO TO 133
13100 RETRO=-1.
13200 I=1
13300 PARENS=0
13400 MOT=0
13500 JZ=1
13600 IAMP=0
13700 C IAMP IS 'BLANK LINE'FLAG ON PP1-3.
13800 KL=0
13900 RA=0
14000 2408 MLX=1
14100 L=-1
14110 IF(RMODE2.EQ.2)CALL PRESCN
14120 C GO SORT OUT THE NEW FORMAT
14200 DO 2999 K=1,72
14300 N=INP(K)
14400 IF(N.EQ.IBLA)GO TO 2999
14500 L=0
14600 IF(N.EQ.ISTAR)GO TO 277
14650 IF(N.NE.ISEMI)GO TO 2999
14700 C READS 72 CHARS. INCLUDING *.
14800 277 INP(K+1)=ISEMI
14900 GO TO 1773
15000 C --- X/Y/Z* --- WITH NO SEMICOLON WORKS FOR THIS PROG. ONLY!
15100 2999 CONTINUE
15200 IF(IREAD)GO TO 8015
15210 TYPE 6999
15220 GO TO 1
15230 6999 FORMAT(' ****** TRY AGAIN ***** ')
15300 CC GO TO 69
15400 C ERROR IF NO '*' OR ';' AT END OF LINE.
15500
15600 1299 IF(JZ.NE.0)GO TO 1773
15610 7773 IF(MODE.NE.2)GO TO 377
15632 IF(RMODE2.EQ.2)GO TO 77732
15655 C ↑↑↑↑↑↑ FOR NEW INPUT FORMAT
15700 377 IF(IREAD.EQ.0)GO TO 77731
15800 C BYPASS IF NOT USING EDIT FILE
15900 READ(22,21141),L,INP
16000 C TO READ 2ND LINE OF NOTE INPUT, IF NEEDED
16100 GO TO 77732
16300 77731 CALL TYPE
16350
16400 IF(INP1.EQ.IBLA)GO TO 7773
16451 WRITE(21,2114)INP
16475 77732 CALL LNEND
16500 JM=-1
16600 JZ=0
16700 GO TO 2408
16800 C 'LISTS' MUST END WITH *
16900 1773 JZ=0
17000 DBST=1.
17020 IF(XDBST)DBST=-DBST
17040 XDBST=0
17100 17731 ML=MLX
17200 IF(PARENS.LE.0.)GO TO 975
17300 C PARENS=-1, OPENS; =1, CLOSES; =0, NONE
17400 3362 PARENS=0
17500 MOT=I-LMOT
17600 IF(LCNT+MOT.LT.198)GO TO 33621
17700 DATA NOMOR/30H(' NO ROOM FOR MOTIVE ',A1/) /
17800 TYPE NOMOR,JMOT
17900 GO TO 1
18000 33621 JLIST(LCNT+1)=MOT
18100 LCNT=LCNT+2
18200 DO 2140 JG=0,MOT-1
18300 2140 RLIST(LCNT+JG)=V(LMOT+JG)
18400 LCNT=LCNT+MOT
18500 IF(IAMP)GO TO 3013
18700 C FOR CLOSE PARENS ON LAST ITEM
18800 C STORE MOTIVE IN RLIST ARRAY
18900
19000 975 DO 236 JDD=ML,72
19100 JD=JDD
19200 N=INP(JD)
19300 C ((((())))) MAY 13,71 /Z (D4/E/X 2 3/) CS/ ETC. CAN USE 26 LABELS.
19400 IF(N.EQ.ILP)GO TO 477
19450 IF(N.EQ.IRP)GO TO 477
19475 IF(N.NE.ICOL)GO TO 2361
19500 477 INP(JD)=IBLA
19600 IF(N.NE.ICOL)GO TO 1113
19720 XDBST=-1.
19740 GO TO 5362
19750 C GO CHANGE IT TO A SEMIC. !!! CAN'T END LINE WITH :
19760 C SO NEXT NOTE WILL BE DBST (TYPE /F:A:C/ ETC.)
19780 C DBSTS WILL BE ONLY ONE 'REP' UNIT X*0Z%~#&@
19900 C FOR 'DOUBLE STOPS'
20000 1113 L=JD-1
20100 5113 IF(INP(L).NE.IBLA)GO TO 2113
20200 L=L-1
20300 GO TO 5113
20400 2113 IF(N.EQ.')')GO TO 3361
20500 C ONLY ONE () AS YET, NO NESTING
20600 1140 JMOT=INP(L)
20700 C MOTIVE NAME
20800 DO 11401 JC=1,LCNT-1
20900 IF(JMOT.NE.JLIST(JC))GO TO 11401
21000 C FINDS DUPLICATE IDENTIFIER
21200 11402 FORMAT(' MOTIVIC (',A1,') USED TWICE')
21400 TYPE 11402,JMOT
21450 JLIST(JC)=0
21475 C ZERO OUT PREVIOUS USE OF IDENTIFIER.
21500 11401 CONTINUE
21600 JLIST(LCNT)=JMOT
21700 PARENS=-1.
21800 C A PARENTH IS OPEN
21900 INP(L)=IBLA
22000 LMOT=I
22100 C LMOT IS CURRENT POINT IN V ARRAY
22200 GO TO 236
22300 3361 IF(PARENS.NE.0)GO TO 33612
22400 DATA WARN/30H(' PARENTH ERROR - GOING ON'/)/
22500 TYPE WARN
22600 33611 INP(JD)=IBLA
22700 GO TO 236
22800 33612 PARENS=1.
22900 C SETS PARENS CLOSED FLAG
23000 GO TO 33611
23100 C NO INVERSIONS POSSIBLE NOW
23200 2361 IF(N.NE.IAT)GO TO 5361
23300 DO 113 L=1,72
23400 K=JD+L
23500 C K IS USED AT 240!!!
23600 JG=INP(K)
23700 IF(JG.NE.NEG)GO TO 7113
23800 RETRO=0
23900 INP(K)=IBLA
24000 GO TO 113
24100 7113 IF(JG.NE.IBLA)GO TO 4113
24200 113 CONTINUE
24300 4113 DO 6361 L=1,LCNT
24400 IF(JG.NE.JLIST(L))GO TO 6361
24500 VX1=0
24600 DO 40 M=JD+2,72
24700 JG=INP(M)
24800 IF(JG.EQ.IBLA)GO TO 40
24900 IF(JG.EQ.KSLA)GO TO 140
24950 IF(JG.EQ.ISEMI)GO TO 140
24975 IF(JG.EQ.ISTAR)GO TO 140
25000 ML=M
25100 GO TO 240
25200 40 CONTINUE
25300 240 JC=JM
25400 JM=-1
25500 INP(K)=IBLA
25600 JN=0
25700 C MUST BE ZERO IN SCANR
25800 CALL SCANR
25900 JM=JC
26000 140 JC=1
26100 KN=L+2
26210 M=KN+JLIST(L+1)
26300 IF(RETRO)GO TO 940
26400 KN=M-1
26550 M=L+1
26600 JC=-1
26700 RETRO=-1.
26800
26900 940 Z=RLIST(KN)
27000 IF(VX1.EQ.0)GO TO 540
27100 C " @Q N " WHERE N= 1/2 STEPS IN 'NOTES' OR MULT FACTOR IN OTHERS.
27200 IF(MODE.EQ.1)GO TO 440
27300 C MODE 1 IS NOTES, 2 IS RHY.
27400 V(I)=Z*VX1
27500 GO TO 7361
27600 440 IF(Z.EQ.85.)GO TO 540
27605 RB=VX1
27610 IF(Z)RB=-RB
27620 C NOW TRANSPOSES BY DIAT. STEPS ONLY 1000S=FLAT, 10000S=SHARP, 100000S=NAT
27630 C NEG NUMS ARE CHORD NOTES.
27700 V(I)=Z+RB
27800 GO TO 7361
27900 540 V(I)=Z
28000 7361 I=I+1
28100 KN=KN+JC
28200 IF(KN.NE.M)GO TO 940
28300
28400 RB=V(I-1)
28600 DO 8361 L=JD,72
28700 JG=INP(L)
28800 INP(L)=IBLA
28900 IF(JG.EQ.KSLA)GO TO 9361
29000 IF(JG.EQ.ISEMI)GO TO 93611
29200 8361 IF(JG.EQ.ISTAR)IAMP=-1
29300 9361 MLX=L
29400 IF(IAMP.EQ.0)GO TO 17731
29600 JZ=-1
29700 93611 IF(IAMP)GO TO 3013
29900 GO TO 7773
30000 6361 CONTINUE
30100 TYPE 6362,JG
30200 GO TO 11402
30300 6362 FORMAT(' MOTIVIC (',A1,') NOT FOUND')
30400 C @@@@@@@@@@@@@@@@@@@@@@@@@@
30500 5361 IF(N.NE.KSLA)GO TO 636
30600 5362 MLX=JD+1
30700 JZ=-1
30800 INP(JD)=ISEMI
30900 436 IF(INP(MLX).NE.IBLA)GO TO 103
31000 MLX=MLX+1
31100 GO TO 436
31200 636 IF(N.EQ.ISEMI)GO TO 103
31300 936 IF(N.NE.IDOT)GO TO 736
31400 L=INP(JD+1)
31500 KL=NALF(L)
31600 IF(L.LE.0)GO TO 577
31650 IF(KL.LT.0)GO TO 577
31675 IF(KL.LE.9)GO TO 236
31700 C JUMP IF IT'S A NUMBER
31800 577 IF(MODE.EQ.2)INP(JD)=1
31900 C :::::::::******* ↑↑↑↑ MODE #?
32000 GO TO 236
32100 C CHANGES DOTTED RHYTHMS TO '1'S.
32200 736 IF(N.NE.ISTAR)GO TO 236
32300 IAMP=-1
32400 INP(JD)=ISEMI
32600 GO TO 103
32700 236 CONTINUE
00200 2114 FORMAT(72A1)
00300 21141 FORMAT(I,72A1)
09900
10000 5016 IF(IAMP.GE.0)GO TO 1299
10100 IF(PARENS.NE.0)GO TO 3362
10200 C PARENS ARE STILL OPEN?
10300 GO TO 3013
10400 103 K=INP(ML)
10500
10600 C LAST SECTION
10700 IF(K.EQ.ISEMI)GO TO 1014
10800 C*********** MODE #?
10900 IF(K.NE.IBLA) GO TO 1899
11000 ML=ML+1
11100 GO TO 103
11200 1899 JN=0
11300 C MUST BE ZERO IN SCANR
11400 CALL SCANR
11500 IF(VX1.EQ.-99.)GO TO 4022
11600 IF(MODE.NE.2)GO TO 17
11700 C*********** MODE #?
11800 2017 IF(VX1.EQ.10000.)GO TO 17
11900 VX1=4./VX1
12000 IF(JJ.NE.1)GO TO 2014
12100 V(I)=VX1
12200 GO TO 114
12300 2014 DO 9006 L=2,JJ
12400 IF(VX(L).EQ.0)GO TO 17
12500 9006 VX1=4./VX(L)+VX1
12600 JJ=1
12700 17 V(I)=VX1
12800 IF(JJ.LE.1)GO TO 114
12900 IF(MODE.NE.1)GO TO 171
12950 IF(VX2.EQ.0)GO TO 171
13000 C JUMP IF RHY OR 'X 4' ETC.
13100 V(I)=-(VX1/100.+VX2/10000.)
13200 C PACKS 2 METER NUMS INTO ONE SLOT (-.1208 = 12/8)
13310 114 I=I+1
13320 GO TO 5016
13400 171 JC=1
13500 JD=VX(JJ)-1
13525 I=I+1
13550 GO TO 5005
13650 1014 JD=1
13750 JC=1
13850 C X4/ CREATES REP 1,4; A/// CREATES REP 1,3;
13950 GO TO 5005
14600 4022 JC=VX2+.3
14700 JD=VX3-.5
14800 IF(JJ.EQ.2)JD=1
14900 C JD=HOW MANY TIMES, JC=HOW MANY NOTES
14910 5005 N=0
14920 DO 3005 K=I-1,1,-1
14930 IF(V(K).GT.0)N=N+1
14940 3005 IF(N.EQ.JC)GO TO 4005
14950 4005 JC=I-K
14960 C ALL THIS IS TO FIND COMPLETE CHORDS, BARS, ETC. TO REPEAT.
14970 C REPS WILL ONLY COUNT RHYTHMIC UNITS.!
15000 DO 1005 K=1,JD
15100 NL=I+JC-1
15200 DO 2005 L=I,NL
15300 2005 V(L)=V(L-JC)
15400 1005 I=I+JC
15700 GO TO 5016
15800
15900 3013 IF(MODE.NE.2)GO TO 771
15950 IF(I-1.NE.IRHY)GO TO 8015
16000 C WRONG NUMBER OF ITEMS
16100 771 V(I)=-99.
16200 IF(MODE.NE.1)GO TO 132
16210 NIT=ITEM+1
16215 C FOR ADDED NOTES ON SPACING STAFF
16220 CALL NOTES
16250 JIT=IZ
16275 C SAVES TOTAL OF ITEMS FOR LABEL 168
16310 67 CALL NEWR
16400 GO TO 8006
16450 132 IF(IREAD.GT.0)IREAD=-1
16500 CALL RHYTH
16700 C =50 IS RHYTHM FOR TEXT
16950 GO TO 67
16955 134 WRITE(21,2114)N,L,INP3
16960 INP3='B'
16980 INP2=0
17000 C ACCENTS ARE IN BEAMS SUBROUTINE
17100 133 CALL BEAMS
17110 IF(MODE.EQ.3)GO TO 135
17155 IF(MODE.EQ.4)IBEAM=0
17177 C ADJUSTS STEMS (IBEAM=0) IF BEAMS WERE ENTERED.
17200 GO TO 8006
17600 135 K=IS
17700 CALL NEWR
17800 IS=K
17900 C ↑↑↑↑↑↑ TO ADD NEW ITEMS, SUCH AS PPP, MP, CRESC., ETC.(SEE 'MARKS')
18000 GO TO 8006
18100 END